home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Atari Mega Archive 1
/
Atari Mega Archive - Volume 1.iso
/
graphics
/
escher.arc
/
CUBED.BAS
next >
Wrap
BASIC Source File
|
1987-05-04
|
30KB
|
587 lines
100 '***************************** ESCHER CUBES ******************************
110 '***************************** By Jim Luczak *****************************
120 '*************************** Ver 1.4d 2/6/87 ****************************
130 dim mhl(26),cl0(15),cl1(15),cl2(15),cl3(15),tx(56),titlep(10),ctx$(10)
140 max=5000:dim ps(5000),fv(10),fm(4):path=0:icon=3:priority=2
150 a#=gb:gintin=peek(a#+8):gintout=peek(a#+12):pl#=1114
160 addrin=peek(a#+16):path$="\*.CUB":path1$=path$+string$(24,chr$(0))
170 test$="\"+chr$(14)+chr$(15):button$="CANCEL|DELETE":button1$=button$
180 box$="Verify DELETE Operation":box1$=box$
190 if peek(systab)=4 then goto LOWREZMSG
200 if peek(systab)=2 then restore MEDREZ
210 if peek(systab)=1 then restore HIREZ
220 read v1,v2,v3,v4,v5,st,t1,t2,cm1,cm2,j,j1,txty,rz,dfy,dth,ta,mkc1
230 read y7,y8,y12,y13,ta2,ta3,ta4,ta5
240 for x=1 to 4:read fm(x):next x
250 for x=1 to 10:read fv(x):next x
260 for x=0 to 15:read cl0(x):next x
270 for x=0 to 15:read cl1(x):next x
280 for x=0 to 15:read cl2(x):next x
290 for x=0 to 15:read cl3(x):next x
300 restore CBARDAT
310 for x=1 to 26:read mhl(x):next x
320 for x=0 to 56:read tx(x):next x
330 for x=0 to 10:read titlep(x):next x
340 restore CNTDATA
350 for x=1 to 9:read ctx$(x):next x
360 ctx$(10)=chr$(14)+chr$(15)+" Exit Program "+chr$(14)+chr$(15)
370 sz=4:a=cm1*sz:b=cm2*sz:c=3*sz:sd=4:sd1=4
380 dfx=304:lv=-1:lh=0:mkc2=3:c1=1:c2=2:c3=3
390 ind=2:st1=st:ts=30/j:rzm=1:lc=3:lc1=1:lc2=2:cl$=space$(50)
400 title$=chr$(32)+chr$(1)+chr$(32)+chr$(2)+chr$(32)+chr$(3)+chr$(32)+chr$(4)
410 title$=title$+chr$(32)+chr$(t1)+chr$(32)+chr$(t2)
420 title$=title$+" Col= 0 Bkg= 0 Fill= Erase OFF Clear "
430 title$=title$+"Size= 4 "+chr$(8)+chr$(32)+chr$(0)
440 tlt1$=chr$(32)+chr$(14)+chr$(15)+" Escher Cubes File Control "
450 tlt1$=tlt1$+chr$(14)+chr$(15)+chr$(32)+chr$(0)
460 tlt2$=" 1= "+chr$(1)+" 2= "+chr$(2)+" 3= "+chr$(3)+" 4= "+chr$(4)
470 tlt2$=tlt2$+" 5= "+chr$(t1)+" 6= "+chr$(t2)
480 tlt2$=tlt2$+" 7= Col"+chr$(1)+" 8= Bkg"+chr$(1)+" 9= Fill"
490 tlt2$=tlt2$+chr$(1)+chr$(32)+chr$(0)
500 tlt3$=" Escher Cubes "+chr$(0)
510 eds$=" 10= Erase ON/OFF 11= Clear 12= Size"+chr$(1)
520 eds$=eds$+" 14= Col"+chr$(2)+" 16= Bkg"+chr$(2)+" 18= Fill"+chr$(2)
530 eds1$=" 24= Size"+chr$(2)+" -1= Place Cube XXX YYY -2= NUL"
540 eds1$=eds1$+" -3= End -4= Hi -8= Lo"
550 gosub TITLEPAGE:poke systab+24,1:gosub SETCOLOR
560 txsz=56:txtx=161:gosub DOTEXT:gosub DOCONTROLS
570 restore CUBEP:gosub MOUSEFORM
580 x=dfx:y=dfy:mx1=dfx:my1=dfy:x1=dfx:y1=dfy
590 '----------------------------- MOUSE CONTROLLER -------------------------
600 gosub MOUSEON
610 mk=0:hc1=-2:while mk=0
620 poke contrl,124:poke contrl+2,0:poke contrl+6,0:vdisys(1)
630 mx=peek(ptsout):my=peek(ptsout+2):mkey=peek(intout)
640 if mkey=1 or mkey=2 then gosub CHECKMOUSE
650 if hc1>0 and hc1<7 then gosub DOCUBE
660 if hc1>6 and hc1<14 then gosub CONTROLBAR
670 if hc1=14 then mx=mx1:my=my1:hc1=-1
680 if hc1=15 then mx=x1:my=y1:hc1=-1
690 if mkey=2 then hc1=-2:gosub COORD
700 if hc1=-1 then gosub PLACECUBE
710 hc1=-2:wend
720 '--------------------------- CLEAN-UP AND END ---------------------------
730 CLEANUP:gosub MOUSEOFF
740 clearw 2:poke systab+24,0:tlt=1:title$=" OUTPUT "+chr$(0)
750 gosub DOCONTROLS:plt%(0)=1911:plt%(1)=1792:plt%(2)=112:plt%(3)=0
760 poke pl#,varptr(plt%(0)):color 1,1,1
770 restore DEFAULTP:gosub MOUSEFORM:clear:end
780 '------------------------ LOW RESOLUTION MESSAGE -----------------------
790 LOWREZMSG:icon=1:priority=1:box1$=" |":fullw 2:clearw 2
800 box$=chr$(14)+chr$(15)+" ESCHER CUBES "+chr$(14)+chr$(15)+"|"
810 box$=box$+box1$+chr$(3)+" Set Preference To "+chr$(4)
820 button$=chr$(175)+" MEDIUM RESOLUTION "+chr$(174):gosub FORMBOX:end
830 '---------------------------- ERROR HANDLER -----------------------------
840 close #1:if dp=1 then dp=0:goto ERD
850 open "R",#1,f$,3:field #1,3 as am$:lset am$=a$:put #1,1:close #1:kill f$
860 ERD:?chr$(7);:resume GETANS1
870 '------------------------------- MOUSE ON -------------------------------
880 MOUSEON:poke gintin,257:gemsys(78):return
890 '------------------------------- MOUSE OFF ------------------------------
900 MOUSEOFF:poke gintin,256:gemsys(78):return
910 '-------------------------- CHECK MOUSE LOCATION ------------------------
920 CHECKMOUSE:
930 mc=0:hc=1:hc1=1:hct=26
940 if my<v1 then gosub MCC:return
950 if my>v2 then hc1=-1:return
960 while mc=0
970 if mx>=mhl(hc) and mx<=mhl(hc+1) then mc=1
980 if mc=0 then hc1=hc1+1
990 hc=hc+2:if hc>hct then mc=1
1000 wend:if hc1>hct/2 then hc1=-1
1010 return
1020 MCC:if mx>162 and mx<353 then hc1=14:return
1030 if mx>354 and mx<532 then hc1=15:return
1040 hc1=-2:return
1050 '----------------------- CONTROL BAR CONTROLLER -------------------------
1060 CONTROLBAR:
1070 on hc1-6 goto CB1,CB2,CB3,CB4,CB5,CB6,CB7
1080 CB1:if mkey=1 then cr1=cr1+1:if cr1>15 then cr1=0
1090 if mkey=2 then cr1=cr1-1:t=1:if cr1<0 then cr1=15
1100 gosub DOCUCOL:goto BARDONE
1110 CB2:if mkey=1 then cr0=cr0+1:if cr0>15 then cr0=0
1120 if mkey=2 then cr0=cr0-1:t=1:if cr0<0 then cr0=15
1130 gosub DOBCK:goto BARDONE
1140 CB3:if mkey=1 then gosub PATUP
1150 if mkey=2 then gosub PATDN
1160 gosub DOSTYLE:goto BARDONE
1170 CB4:gosub DOERASE:goto BARDONE
1180 CB5:gosub CLEARSCR:goto BARDONE
1190 CB6:if mkey=1 then sz=sz+1:if sz>12 then sz=1
1200 if mkey=2 then sz=sz-1:t=1:if sz<1 then sz=12
1210 gosub DOSIZE:goto BARDONE
1220 CB7:goto CNTSCREEN
1230 CB7A:ps(h)=hc1:gosub CLEARSCR:gosub PLAYBACK:goto BARD
1240 BARDONE:ps(h)=hc1:if t=1 then t=0:ps(h)=hc1*2
1250 h=h+1:if h>max then h=max:ps(h)=13
1260 BARD:mkey=1:return
1270 PATUP:st=st+1:if st>24 then st=1:ind=3
1280 if st>12 and ind=3 then ind=2:st=1
1290 return
1300 PATDN:st=st-1:t=1:if st<1 and ind=2 then ind=3:st=12
1310 if st<1 and ind=3 then ind=2:st=24
1320 return
1330 '--------------------------- CUBE CONTROLLER ----------------------------
1340 DOCUBE:gosub MOUSEOFF
1350 on hc1 goto UP,DOWN,RIGHT,LEFT,FORWARD,BACKWARD
1360 UP:y=y-b:gosub SETCUBE:gosub DOBOX:goto CUBEDONE
1370 DOWN:y=y+b:if hc2=3 then sd=4:sd1=3
1380 if hc2=6 then sd=3:sd1=4
1390 gosub SETCUBE:gosub FRONT:sd=sd1:gosub SIDE:goto CUBEDONE
1400 RIGHT:x=x+c:y=y-a:gosub SETCUBE
1410 if hc2=2 then sd=4:sd1=3:gosub SETRTOP
1420 if hc2=6 then sd=3:sd1=4:gosub SETRFRONT
1430 gosub FRONT:sd=sd1:gosub TOP:goto CUBEDONE
1440 LEFT:x=x-c:y=y+a:gosub SETCUBE:gosub DOBOX:goto CUBEDONE
1450 FORWARD:x=x+c:y=y+a:gosub SETCUBE:gosub DOBOX:goto CUBEDONE
1460 BACKWARD:x=x-c:y=y-a:gosub SETCUBE
1470 if hc2=2 then sd=3:sd1=4
1480 if hc2=3 then sd=4:sd1=3:gosub SETBSIDE
1490 gosub TOP:sd=sd1:gosub SIDE
1500 CUBEDONE:hc2=hc1:sd=4:sd1=4:gosub MOUSEON
1510 gosub DOSOUND:mkey=1:ps(h)=hc1
1520 h=h+1:if h>max then h=max:ps(h)=13
1530 return
1540 '----------------------------- PLACE CUBE -------------------------------
1550 PLACECUBE:x=mx:y=my*rzm:hc2=hc1
1560 if h+3>max then goto PL1
1570 ps(h)=hc1:ps(h+1)=mx:ps(h+2)=my
1580 gosub DOBOXA:gosub MOUSEON
1590 PL1:h=h+3:if h>max then h=max:ps(h)=13
1600 return
1610 '------------------------------ CLEAR SCREEN ----------------------------
1620 CLEARSCR:if t3<>1 then reset:gosub MOUSEOFF:clearw 2:gosub MOUSEON
1630 er=1:sz=4:st=st1:cr0=0:cr1=0:ind=2:gosub DOCUCOL
1640 x=dfx:y=dfy:mx1=dfx:my1=dfy:x1=dfx:y1=dfy
1650 gosub DOSIZE:gosub DOERASE:gosub DOBCK
1660 restore COORDTEXT:for z=0 to 5:read tx(z):next z
1670 v6=v3:v3=0:v7=v4:v4=639:gosub SETCLIP:v3=v6:v4=v7
1680 txsz=56:txtx=161:gosub DOTEXT:gosub SETCLIP:return
1690 '---------------------------- DRAW WHOLE CUBE ---------------------------
1700 DOBOXA:gosub SETCUBE:gosub DOSOUND:gosub MOUSEOFF
1710 DOBOX:gosub FRONT:gosub TOP:gosub SIDE:return
1720 '--------------------------- DRAW CUBE TOP ---------------------------